perm filename CYCOMF.PRT[4,LMM] blob sn#037536 filedate 1973-04-23 generic text, type T, neo UTF8
  (DEFPROP CYCOMFFNS
           (CYCOMFFNS ORDPAIR EDGEMARK LABEL1C MAKEMULT MAKENODES 
                      MAKEEDGES LABELMULT LABEL0A LABELN LABELE UNCLASS 
                      LUNCLASS)
           VALUE)
  (DEFPROP ORDPAIR (LAMBDA (X1 X2)
                           (IF (LEQ X1 X2)
                               THEN
                               (CONS X1 X2)
                               ELSE
                               (CONS X2 X1)))
           EXPR)
  (DEFPROP EDGEMARK (LAMBDA (EDG)
                            (ORDPAIR (NODEMARK (NODE1 EDG))
                                     (NODEMARK (NODE2 EDG))))
           EXPR)
  (DEFPROP LABEL1C
           (LAMBDA (OBJECTS LABELS STRUC)
                   (IF (ZEROP LABELS)
                       THEN
                       (LIST (LABELING UNLABELED = OBJECTS LSTRUC = 
                                       STRUC))
                       ELSEIF
                       (EQUAL LABELS (SIZE OBJECTS))
                       THEN
                       (LIST (LABELING LABELED = OBJECTS LSTRUC = STRUC)
                             )
                       ELSEIF
                       (NODES? OBJECTS)
                       THEN
                       (LABELN (NODENUMS OBJECTS)
                               LABELS STRUC)
                       ELSEIF
                       (EDGES? OBJECTS)
                       THEN
                       (LABELE (NODEPRS OBJECTS)
                               LABELS STRUC)
                       ELSEIF
                       (MULTTYPE? OBJECTS)
                       THEN
                       (LABELMULT (MULT OBJECTS)
                                  (UNMULTED OBJECTS)
                                  LABELS STRUC)
                       ELSE
                       (LABELUNDEFINEDSTRUC OBJECTS LABELS STRUC)))
           EXPR)
  (DEFPROP MAKEMULT
           (LAMBDA (M OBJ)
                   (IF (ZEROP M)
                       THEN NIL ELSEIF (EQUAL M 1.0)
                       THEN OBJ ELSE
                       (MULTTYPE MULT = M UNMULTED = OBJ)))
           EXPR)
  (DEFPROP MAKENODES (LAMBDA (NODES)
                             (IF (NOT NODES)
                                 THEN NIL ELSE (NODETYPE NODENUMS = 
                                                         NODES)))
           EXPR)
  (DEFPROP MAKEEDGES (LAMBDA (EDGES)
                             (IF (NOT EDGES)
                                 THEN NIL ELSE (EDGETYPE NODEPRS = 
                                                         EDGES)))
           EXPR)
  (DEFPROP
    LABELMULT
    (LAMBDA
      (MULTS UNMULTED LABELS STRUC)
      (FOR NEW P IN (NUMPARTITIONS LABELS (SIZE UNMULTED)
                                   0.0 MULTS)
           AS NEW CLP IS (CLCREATE P)
           FOR NEW L IN (LABELM UNMULTED (CDRLIST CLP)
                                STRUC)
           XLIST
           (LABELING FROM L LABELED =
                     (FOR NEW X IN ** AS NEW PR IN CLP COMBINE FIRST 
                          NIL (MAKEMULT (CAR PR)
                                        X))
                     UNLABELED =
                     (FOR NEW X IN (LABELED L)
                          AS NEW PR IN CLP COMBINE FIRST NIL
                          (MAKEMULT (DIFFERENCE MULTS (CAR PR))
                                    X)))))
    EXPR)
  (DEFPROP
    LABEL0A
    (LAMBDA
      (OBJECTS STRUC NPL LABELS MAKEFN)
      (FOR NEW L IN
           (IF (NOT (REMPERMS NPL))
               THEN
               (COMB1 OBJECTS NIL NIL (OKPERMS NPL)
                      LABELS)
               ELSE
               (COMB OBJECTS NIL (DIFF (OBJ (CAR (REMPERMS NPL)))
                                       OBJECTS)
                     NPL LABELS))
           XLIST
           (LABELING FROM L LABELED = (MAKEFN **)
                     UNLABELED = (MAKEFN (DIFF OBJECTS (LABELED L)))
                     LSTRUC = (STRUCTURE FROM STRUC GROUP =
                                         (LSTRUC L)))))
    EXPR)
  (DEFPROP LABELN (LAMBDA (NODENUMS LABELS STRUC)
                          (LABEL0A NODENUMS STRUC (FINDGROUPNODES
                                     NODENUMS STRUC)
                                   LABELS
                                   (FUNCTION MAKENODES)))
           EXPR)
  (DEFPROP LABELE (LAMBDA (EDGES LABELS STRUC)
                          (LABEL0A EDGES STRUC (FINDGROUPEDGES EDGES 
                                                              STRUC)
                                   LABELS
                                   (FUNCTION MAKEEDGES)))
           EXPR)
  (DEFPROP UNCLASS
           (LAMBDA (OBJECTS)
                   (IF (NOT OBJECTS)
                       THEN NIL ELSEIF (UNCLASSED? OBJECTS)
                       THEN
                       (OBJECTS OBJECTS)
                       ELSEIF
                       (NODES? OBJECTS)
                       THEN
                       (NODENUMS OBJECTS)
                       ELSEIF
                       (EDGES? OBJECTS)
                       THEN
                       (NODEPRS OBJECTS)
                       ELSEIF
                       (MULTTYPE? OBJECTS)
                       THEN
                       (FOR NEW M := (1.0 (MULT OBJECTS))
                            APPEND
                            (UNCLASS (UNMULTED OBJECTS)))
                       ELSEIF
                       (COMBINATION? OBJECTS)
                       THEN
                       (APPEND (UNCLASS (OBJ1 OBJECTS))
                               (UNCLASS (OBJ2 OBJECTS)))
                       ELSE
                       (PRINT (CONS OBJECTS
                                    (QUOTE (ERROR ARG TO UNCLASS)))
                              NIL)))
           EXPR)
  (DEFPROP LUNCLASS (LAMBDA (LOBJ)
                            (MAPCAR (QUOTE UNCLASS)
                                    LOBJ))
           EXPR)
STOP